perm filename FLIP.LSP[900,BGB] blob
sn#129569 filedate 1974-11-11 generic text, type T, neo UTF8
(SETQ IBASE (ADD1 7))
(DEFPROP ALLFNS
(NIL QUALITY
ZZZ
ZAHN1
YMERGE
ZAHNLIST2
ZAHNLIST
ADJACENT
RUNN
BACKWARD
FORWARD
ENDSEG
SEGEND
PACLIST
PACLIST2
CLINT
FLASH
TOD
TEST2
VTEST2
SCALEX
SCALEY
HISTA
HISTA2
SCALE
HISTI
HISTI2
LSDTEST
POINT
HTEST2
DARDS
VTEST
HTEST
MB
PLINE
CW
AW
BORDER
DIII
MIDPOINT
PERIMETER
HSEGS
VSEGS
HSEG
VSEG
FILM
ASHCAN
BLOBS?
SMG
BASKET
INK
ONEBLOB
TEST
QFLIP
QUILT
ALLI
ALLPAC
XY
BUBBLE
ARDSFIT
BITS
SQRED
FLATTEN
FIT
MID
ADDPTS
ONE16
OPEN
CLOSE
MOMENT
MEANX
MEANY
SORT2
SORT
CROSSZ
HIST
DIFFS
CROSSINGS
INITFLIP
SAFE)
VALUE)
(DEFPROP QUALITY
(LAMBDA(M N)
(PROG (MM NN)
(SETQ MM (LSH 2 (SUB1 M)))
(SETQ NN (LSH 2 (SUB1 N)))
(ZIPALL)
L1 (TV Z)
(WINDOW 70 34 3 3)
(TVADD 0)
(COND ((NOT (ZEROP (SETQ MM (SUB1 MM)))) (GO L1)))
L2 (TV Z)
(WINDOW 70 34 3 3)
(TVADD 1)
(COND ((NOT (ZEROP (SETQ NN (SUB1 NN)))) (GO L2)))
(CASH 1 (DIFFERENCE M N))
(SUBC 0 1)
(CROUND 0 (DIFFERENCE M N))
(HISTO 0)
(HISTA 0)))
EXPR)
(DEFPROP ZZZ
(LAMBDA NIL
(PROG (N) (SETQ N 144) L (SIEVE 0 0 4 14) (SETQ N (SUB1 N)) (COND ((ZEROP N) (RETURN NIL))) (GO L)))
EXPR)
(DEFPROP ZAHN1
(LAMBDA(PAC)
(PROG (ZZZ YYY)
(BLIT PAC 11)
(PAXSH 11 1)
(BLIT 11 12)
(PAXSH 12 1)
(BLIT 11 14)
(PAYSH 14 -1)
(BLIT 14 13)
(PAXSH 13 -1)
(BLIT 14 15)
(PAXSH 15 1)
(BLIT 14 17)
(PAYSH 17 -1)
(BLIT 17 16)
(PAXSH 16 -1)
(BLIT 11 20)
(BLIT 14 21)
(BONLY 11 21)
(BONLY 14 20)
(BLIT 20 10)
(PAND 13 10)
(PAND 15 10)
(SETQ Z71 (ZAHNLIST 10 (CONS 7 1) 0 1))
(BLIT 21 10)
(PAND PAC 10)
(PAND 12 10)
(SETQ Z35 (YMERGE (ZAHNLIST 10 (CONS 3 5) 0 1) ZZZ))
(BLIT PAC 22)
(BLIT 13 23)
(BONLY PAC 23)
(BONLY 13 22)
(BLIT 15 10)
(PAND 22 10)
(PAND 20 10)
(SETQ Z34 (YMERGE (ZAHNLIST 10 (CONS 3 4) 0 1) ZZZ))
(BLIT 12 10)
(PAND 23 10)
(PAND 21 10)
(SETQ Z01 (YMERGE (ZAHNLIST 10 (CONS 0 1) 0 1) ZZZ))
(BLIT 20 10)
(PAND 12 10)
(PAND 13 10)
(BONLY 15 10)
(SETQ Z45 (YMERGE (ZAHNLIST 10 (CONS 4 5) 0 1) ZZZ))
(BLIT 21 10)
(PAND PAC 10)
(PAND 15 10)
(BONLY 12 10)
(SETQ Z70 (YMERGE (ZAHNLIST 10 (CONS 7 0) 0 1) ZZZ))
(BLIT 12 10)
(NAND 15 10)
(PAND 10 22)
(PAND 10 23)
(PAND 20 22)
(PAND 21 23)
(SETQ Z54 (YMERGE (ZAHNLIST 22 (CONS 5 4) 0 1) ZZZ))
(SETQ Z07 (YMERGE (ZAHNLIST 23 (CONS 0 7) 0 1) ZZZ))
(BLIT 20 22)
(BLIT 21 23)
(PAND 10 20)
(PAND 10 23)
(BLIT 12 10)
(BONLY 15 10)
(PAND 10 22)
(BONLY 12 15)
(PAND 15 21)
(BLIT PAC 10)
(NAND 13 10)
(PAND 10 20)
(PAND 10 21)
(PAND 10 22)
(PAND 10 23)
(SETQ Z17 (YMERGE (ZAHNLIST 20 (CONS 1 7) 0 1) ZZZ))
(SETQ Z43 (YMERGE (ZAHNLIST 22 (CONS 4 3) 0 1) ZZZ))
(SETQ Z10 (YMERGE (ZAHNLIST 21 (CONS 1 0) 0 1) ZZZ))
(SETQ Z53 (YMERGE (ZAHNLIST 23 (CONS 5 3) 0 1) ZZZ))
(BLIT 13 20)
(BLIT 14 21)
(BONLY 13 21)
(BONLY 14 20)
(BLIT 20 10)
(PAND 11 10)
(PAND 17 10)
(SETQ Y57 (ZAHNLIST 10 (CONS 5 7) 1 0))
(BLIT 21 10)
(PAND PAC 10)
(PAND 16 10)
(SETQ Y13 (YMERGE (ZAHNLIST 10 (CONS 1 3) 1 0) YYY))
(BLIT 16 12)
(BLIT 17 15)
(BONLY 16 15)
(BONLY 17 12)
(BLIT PAC 22)
(BLIT 11 23)
(BONLY PAC 23)
(BONLY 11 22)
(BLIT 23 10)
(PAND 21 10)
(PAND 16 10)
(SETQ Y12 (YMERGE (ZAHNLIST 10 (CONS 1 2) 1 0) YYY))
(BLIT 21 10)
(PAND 15 10)
(PAND PAC 10)
(SETQ Y23 (YMERGE (ZAHNLIST 10 (CONS 2 3) 1 0) YYY))
(BLIT 20 10)
(PAND 12 10)
(PAND 11 10)
(SETQ Y56 (YMERGE (ZAHNLIST 10 (CONS 5 6) 1 0) YYY))
(BLIT 22 10)
(PAND 20 10)
(PAND 17 10)
(SETQ Y67 (YMERGE (ZAHNLIST 10 (CONS 6 7) 1 0) YYY))
(NAND PAC 11)
(NAND 16 17)
(PAND 11 12)
(PAND 11 15)
(PAND 20 12)
(PAND 21 15)
(SETQ Y76 (YMERGE (ZAHNLIST 12 (CONS 7 6) 1 0) YYY))
(SETQ Y21 (YMERGE (ZAHNLIST 15 (CONS 2 1) 1 0) YYY))
(BLIT 20 12)
(BLIT 21 15)
(PAND 11 12)
(PAND 11 21)
(PAND 23 15)
(PAND 22 20)
(PAND 17 12)
(PAND 17 21)
(PAND 17 15)
(PAND 17 20)
(SETQ Y75 (YMERGE (ZAHNLIST 12 (CONS 7 5) 1 0) YYY))
(SETQ Y31 (YMERGE (ZAHNLIST 21 (CONS 3 1) 1 0) YYY))
(SETQ Y32 (YMERGE (ZAHNLIST 15 (CONS 3 2) 1 0) YYY))
(SETQ Y65 (YMERGE (ZAHNLIST 20 (CONS 6 5) 1 0) YYY))
(RETURN (YMERGE YYY ZZZ))))
EXPR)
(DEFPROP YMERGE
(LAMBDA(A B)
(COND ((NULL A) B)
((NULL B) A)
((LESSP (CDDAR A) (CDDAR B)) (CONS (CAR A) (YMERGE (CDR A) B)))
((LESSP (CDDAR B) (CDDAR A)) (CONS (CAR B) (YMERGE A (CDR B))))
((LESSP (CADAR A) (CADAR B)) (CONS (CAR A) (YMERGE (CDR A) B)))
(T (CONS (CAR B) (YMERGE A (CDR B))))))
EXPR)
(DEFPROP ZAHNLIST2
(LAMBDA(CIO ZZ)
(PROG (XXS YY)
(SETQ XXS (REVERSE ZZ))
(SETQ YY (PLUS DY (CAR XXS) (CAR XXS)))
(SETQ XXS (CDR XXS))
(RETURN (MAPCAR (FUNCTION (LAMBDA (W) (CONS CIO (CONS (PLUS W W DX) YY)))) XXS))))
EXPR)
(DEFPROP ZAHNLIST
(LAMBDA(PAC IO DX DY)
(PROG (A B)
(SETQ A (PACLST PAC))
(SETQ B NIL)
L (COND ((NULL A) (RETURN B)))
(SETQ B (APPEND (ZAHNLIST2 IO (CAR A)) B))
(SETQ A (CDR A))
(GO L)))
EXPR)
(DEFPROP ADJACENT
(LAMBDA(P Q)
(AND (EQ (CADR P) (CAAR Q))
(OR (AND (OR (EQ (CDAR P) 1) (EQ (CDAR P) 5)) (EQ (PLUS (CADR P) (CDDR P)) (PLUS (CADR Q) (CDDR Q))))
(AND (OR (EQ (CDAR P) 3) (EQ (CDAR P) 7))
(EQ (DIFFERENCE (CADR P) (CDDR P)) (DIFFERENCE (CADR Q) (CDDR Q))))
(AND (OR (EQ (CDAR P) 2) (EQ (CDAR P) 6)) (EQ (CADR P) (CADR Q)))
(AND (OR (EQ (CDAR P) 4) (EQ (CDAR P) 0)) (EQ (CDDR P) (CDDR Q))))))
EXPR)
(DEFPROP RUNN
(LAMBDA (N) (PROG (NN) (SETQ NN N) L (RUN) (COND ((MINUSP (SETQ NN (SUB1 NN))) (RETURN (STOP)))) (GO L)))
EXPR)
(DEFPROP BACKWARD
(LAMBDA NIL (PROG NIL (FORE 350) (HEAD 372) (HIND 144)))
EXPR)
(DEFPROP FORWARD
(LAMBDA NIL (PROG NIL (FORE 64) (HEAD 106) (HIND -120)))
EXPR)
(DEFPROP ENDSEG
(LAMBDA(MB X)
(PROG (Y)
(SETQ Y (FIX (PLUS (CDR MB) (TIMES X (CAR MB)))))
(RETURN
(COND ((GREATERP Y 107) (XCONS (FIX (QUOTIENT (DIFFERENCE 107 (CDR MB)) (CAR MB))) 107))
((MINUSP Y) (XCONS (FIX (QUOTIENT (MINUS (CDR MB)) (CAR MB))) 0))
(T (XCONS X Y))))))
EXPR)
(DEFPROP SEGEND
(LAMBDA(MB X)
(PROG (Y)
(SETQ Y (FIX (PLUS (CDR MB) (TIMES X (CAR MB)))))
(RETURN
(COND ((GREATERP Y 107) (CONS (FIX (QUOTIENT (DIFFERENCE 107 (CDR MB)) (CAR MB))) 107))
((MINUSP Y) (CONS (FIX (QUOTIENT (MINUS (CDR MB)) (CAR MB))) 0))
(T (CONS X Y))))))
EXPR)
(DEFPROP PACLIST
(LAMBDA(PAC)
(PROG (A B)
(SETQ A (PACLST PAC))
(SETQ B NIL)
L (COND ((NULL A) (RETURN B)))
(SETQ B (APPEND (PACLIST2 (CAR A)) B))
(SETQ A (CDR A))
(GO L)))
EXPR)
(DEFPROP PACLIST2
(LAMBDA(ZZ)
(PROG (XXS YY)
(SETQ XXS (REVERSE ZZ))
(SETQ YY (CAR XXS))
(SETQ XXS (CDR XXS))
(RETURN (MAPCAR (FUNCTION (LAMBDA (W) (CONS W YY))) XXS))))
EXPR)
(DEFPROP CLINT
(LAMBDA (PAC) (PROG NIL (PNOT PAC 22) (BLOT 22) (PAND 22 PAC)))
EXPR)
(DEFPROP FLASH
(LAMBDA NIL (PROG2 (ARDFF) (ARDEOF)))
EXPR)
(DEFPROP TOD
(LAMBDA NIL
(PROG (A)
(TERPRI)
(SETQ A (NOW))
(SETQ BASE (ADD1 11))
(SETQ *NOPOINT T)
(PRINC (QUOTIENT A 645700))
(PRINC (QUOTE :))
(PRINC (REMAINDER (QUOTIENT A 7020) 74))
(PRINC (QUOTE :))
(PRINC (QUOTIENT (REMAINDER A 7020) 74))
(PRINC (QUOTE :))
(PRINC (REMAINDER A 74))
(SETQ BASE (ADD1 7))))
EXPR)
(DEFPROP TEST2
(LAMBDA NIL (PROG NIL (TV Z) (WINDOW 24 24 4 4) (TVMOVE 0) (ALLI 0) (ALLPAC)))
EXPR)
(DEFPROP VTEST2
(LAMBDA(PAC)
(PROG NIL
(DARDS (APPEND BORDER (MAPCAR (FUNCTION VSEG) (MAPCAR (FUNCTION MB) (PACLIST PAC)))) CW A)
(ARDEOF)))
EXPR)
(DEFPROP SCALEX
(NIL . 1.0)
VALUE)
(DEFPROP SCALEY
(NIL . 0.25)
VALUE)
(DEFPROP HISTA
(LAMBDA(N)
(PROG (TT)
(SETQ TT (HIST N))
(ARDDOT (CAR XY) (CDR XY))
(ARDVEC 0 (FIX (TIMES SCALEY (CAR TT))))
(MAPC (FUNCTION HISTA2) (DIFFS TT))
(ARDVEC (FIX (TIMES SCALEX 100)) 0)
(ARDVEC 0 (FIX (TIMES SCALEY (MINUS (CAR (LAST TT))))))
(ARDEOF)))
EXPR)
(DEFPROP HISTA2
(LAMBDA (ZZ) (PROG2 (ARDVEC (FIX (TIMES SCALEX 100)) 0) (ARDVEC 0 (FIX (TIMES SCALEY (MINUS ZZ))))))
EXPR)
(DEFPROP SCALE
(NIL . 0.25)
VALUE)
(DEFPROP HISTI
(LAMBDA(N)
(PROG (TT)
(SETQ TT (HIST N))
(AIVECT -777 -700)
(RVECT 0 (FIX (TIMES SCALE (CAR TT))))
(MAPC (FUNCTION HISTI2) (DIFFS TT))
(RVECT 100 0)
(AVECT 777 -700)
(SHOW 0)))
EXPR)
(DEFPROP HISTI2
(LAMBDA (ZZ) (PROG2 (RVECT 100 0) (RVECT 0 (FIX (TIMES SCALE (MINUS ZZ))))))
EXPR)
(DEFPROP LSDTEST
(LAMBDA(XX YY)
(PROG NIL
(PZIP 0)
(PDOT 0 XX YY)
(LSD 0)
(SIEVE 1 1 1 2)
(HTEST2 1)
(DARDS (LIST (CONS (CONS -100 YY) (CONS 600 YY)) (CONS (CONS XX -100) (CONS XX 600))) CW AW)))
EXPR)
(DEFPROP POINT
(NIL ((-106 . 30) 300 . 30) ((10 . -200) 10 . 400))
VALUE)
(DEFPROP HTEST2
(LAMBDA(PAC)
(PROG NIL
(DARDS (APPEND BORDER (MAPCAR (FUNCTION HSEG) (MAPCAR (FUNCTION MB) (PACLIST PAC)))) CW A)
(ARDEOF)))
EXPR)
(DEFPROP DARDS
(LAMBDA(LL C A)
(PROG (XXX YYY KX KY CX CY Z ZZ)
(SETQ Z LL)
(SETQ KX (PLUS (CADR A) (TIMES (CAR A) (CADR C))))
(SETQ CX (TIMES (CAR C) (CAR A)))
(SETQ KY (PLUS (CADDDR A) (TIMES (CADDR A) (CADDDR C))))
(SETQ CY (TIMES (CADDR C) (CADDR A)))
L (COND ((NULL Z) (RETURN (ARDEOF))))
(SETQ ZZ (CAR Z))
(SETQ Z (CDR Z))
(ARDDOT (SETQ XXX (PLUS (TIMES CX (CAAR ZZ)) KX)) (SETQ YYY (PLUS (TIMES CY (CDAR ZZ)) KY)))
(ARDVEC (DIFFERENCE (PLUS (TIMES CX (CADR ZZ)) KX) XXX)
(DIFFERENCE (PLUS (TIMES CY (CDDR ZZ)) KY) YYY))
(GO L)))
EXPR)
(DEFPROP VTEST
(LAMBDA(PAC)
(PROG NIL
(CLEAR)
(KILL 0)
(DIII (APPEND BORDER (MAPCAR (FUNCTION VSEG) (MAPCAR (FUNCTION MB) (PACLIST PAC)))) CW AW 0)))
EXPR)
(DEFPROP HTEST
(LAMBDA(PAC)
(PROG NIL
(CLEAR)
(KILL 0)
(DIII (APPEND BORDER (MAPCAR (FUNCTION HSEG) (MAPCAR (FUNCTION MB) (PACLIST PAC)))) CW AW 0)))
EXPR)
(DEFPROP MB
(LAMBDA (VV) (CONS (DIFFERENCE (QUOTIENT (PLUS 0.0 (CDR VV)) 36.0) 1.0) (DIFFERENCE (TIMES 3 (CAR VV)) 107)))
EXPR)
(DEFPROP PLINE
(LAMBDA(PAC V)
(COND
((GREATERP 3 (PLUS (SQRED (DIFFERENCE (CAAR V) (CADR V))) (SQRED (DIFFERENCE (CDAR V) (CDDR V)))))
(PDOT PAC (CAAR V) (CDAR V))
(PDOT PAC (CADR V) (CDDR V)))
(T (PLINE PAC (CONS (MIDPOINT V) (CDR V))) (PLINE PAC (CONS (CAR V) (MIDPOINT V))))))
EXPR)
(DEFPROP CW
(NIL 4 0 4 0)
VALUE)
(DEFPROP AW
(NIL 2 -500 -2 500)
VALUE)
(DEFPROP BORDER
(NIL ((0 . 0) 0 . 107) ((0 . 107) 107 . 107) ((107 . 107) 107 . 0) ((107 . 0) 0 . 0))
VALUE)
(DEFPROP DIII
(LAMBDA(LL C A GLASS)
(PROG (KX KY CX CY Z ZZ)
(SETQ Z LL)
(SETQ KX (PLUS (CADR A) (TIMES (CAR A) (CADR C))))
(SETQ CX (TIMES (CAR C) (CAR A)))
(SETQ KY (PLUS (CADDDR A) (TIMES (CADDR A) (CADDDR C))))
(SETQ CY (TIMES (CADDR C) (CADDR A)))
L (COND ((NULL Z) (RETURN (SHOW GLASS))))
(SETQ ZZ (CAR Z))
(SETQ Z (CDR Z))
(AIVECT (PLUS (TIMES CX (CAAR ZZ)) KX) (PLUS (TIMES CY (CDAR ZZ)) KY))
(AVECT (PLUS (TIMES CX (CADR ZZ)) KX) (PLUS (TIMES CY (CDDR ZZ)) KY))
(GO L)))
EXPR)
(DEFPROP MIDPOINT
(LAMBDA (V) (CONS (QUOTIENT (PLUS (CAAR V) (CADR V)) 2) (QUOTIENT (PLUS (CDAR V) (CDDR V)) 2)))
EXPR)
(DEFPROP PERIMETER
(LAMBDA(PAC)
(PROG (Z)
(INTIOR 20)
(PAND PAC 20)
(PNOT 20 21)
(BLIT 21 22)
(PAXSH 20 1)
(PAND 20 22)
(SETQ Z (AREA 22))
(PAXSH 20 -2)
(BLIT 21 22)
(PAND 20 22)
(SETQ Z (PLUS Z (AREA 22)))
(PAXSH 20 1)
(PAYSH 20 1)
(BLIT 21 22)
(PAND 20 22)
(SETQ Z (PLUS Z (AREA 22)))
(PAYSH 20 -2)
(BLIT 21 22)
(PAND 20 22)
(RETURN (PLUS Z (AREA 22)))))
EXPR)
(DEFPROP HSEGS
(LAMBDA (PAC) (MAPCAR (FUNCTION HSEG) (PACLIST PAC)))
EXPR)
(DEFPROP VSEGS
(LAMBDA (PAC) (MAPCAR (FUNCTION VSEG) (PACLIST PAC)))
EXPR)
(DEFPROP HSEG
(LAMBDA (MB) (CONS (SEGEND MB 0) (SEGEND MB 107)))
EXPR)
(DEFPROP VSEG
(LAMBDA (MB) (CONS (ENDSEG MB 0) (ENDSEG MB 107)))
EXPR)
(DEFPROP FILM
(LAMBDA(N1 N2)
(PROG (NN)
(SETQ LTIM NIL)
(SETQ NN N1)
L (SETQ LTIM (CONS (TV Z) LTIM))
(DRUMO (QUOTIENT NN 10) (REMAINDER NN 10))
(COND ((GREATERP NN N2) (RETURN LTIM)))
(SETQ NN (ADD1 NN))
(GO L)))
EXPR)
(DEFPROP ASHCAN
(LAMBDA NIL
(PROG (Z)
(WINDOW 10 30 3 4)
(TVMOVE 0)
(SIEVE 0 0 4 10)
(BLIT 0 1)
(SMG 1 2)
(SETQ Z NIL)
L (COND ((GREATERP 40 (AREA 1)) (RETURN Z)))
(ONEBLOB 1 2)
(SETQ Z (APPEND (BASKET 2) Z))
(GO L)))
EXPR)
(DEFPROP BLOBS?
(LAMBDA(PAC)
(PROG (NN)
(SETQ NN 0)
(BLIT PAC 22)
L (ONEBLOB 22 21)
(COND ((ZEROP (AREA 21)) (RETURN NN)))
(SETQ NN (ADD1 NN))
(GO L)))
EXPR)
(DEFPROP SMG
(LAMBDA(PAC N)
(PROG (NN)
(SETQ NN (ABS N))
(PNOT PAC 22)
(INK 22 N)
(PFLIP 22)
L (COND ((ZEROP NN) (RETURN (BLIT 22 PAC))))
(BLOT 22)
(PAND PAC 22)
(SETQ NN (SUB1 NN))
(GO L)))
EXPR)
(DEFPROP BASKET
(LAMBDA(N)
(PROG (XM YM XMM XN YN)
(PRINT (AREA N))
(PRINC (QUOTE " AREA"))
(COND ((NOT (GREATERP 740 (AREA N) 40)) (RETURN NIL)))
(SETQ YM (YMAX N))
(SETQ YN (YMIN N))
(SETQ XMM (DIVIDE (XMINW N) 200))
(SETQ XN (CAR XMM))
(SETQ XM (PLUS (CAR XMM) (CDR XMM)))
(PRINT (SETQ DENSITY (QUOTIENT (PLUS 0.0 (AREA N)) (PLUS 0.0 (TIMES (CDR XMM) (DIFFERENCE YM YN))))))
(PRINC (QUOTE " DENSITY"))
(COND ((GREATERP 0.60000000 DENSITY) (RETURN NIL)))
(PRINT (SETQ RATIO (QUOTIENT (PLUS 0.0 (DIFFERENCE YM YN)) (PLUS 0.0 (CDR XMM)))))
(PRINC (QUOTE " RATIO"))
(COND
((GREATERP 1.7000000 RATIO 0.95000000)
(RETURN
(LIST (DIFFERENCE (TIMES 2 DX XN) 1000)
(DIFFERENCE 1000 (TIMES 2 DY YN))
(DIFFERENCE (TIMES 2 DX XM) 1000)
(DIFFERENCE 1000 (TIMES 2 DY YM))))))
(RETURN NIL)))
EXPR)
(DEFPROP INK
(LAMBDA(PAC N)
(PROG (NN) (SETQ NN N) L (COND ((ZEROP NN) (RETURN NIL))) (BLOT PAC) (SETQ NN (SUB1 NN)) (GO L)))
EXPR)
(DEFPROP ONEBLOB
(LAMBDA(M N)
(PROG (A B)
(SETQ A 0)
(PZIP N)
(SEED M N)
L (BLOT N)
(PAND M N)
(SETQ B (AREA N))
(COND ((EQUAL A B) (RETURN (PXOR N M))) (T (SETQ A B) (GO L)))))
EXPR)
(DEFPROP TEST
(LAMBDA NIL (PROG NIL (TV Z) (WINDOW 24 24 3 3) (TVMOVE 0) (HISTO 0) (HISTA 0 XY) (ARDEOF)))
EXPR)
(DEFPROP QFLIP
(NIL 4 -1020 -4 1120)
VALUE)
(DEFPROP QUILT
(LAMBDA (PAC) (PROG NIL (BLOB PAC NIL NIL NIL) (XYFLIP PAC) (BLOB 20 NIL QFLIP T)))
EXPR)
(DEFPROP ALLI
(LAMBDA(N)
(PROG NIL
(SIEVE 0 N 0 1)
(SIEVE 1 N 1 2)
(SIEVE 2 N 2 3)
(SIEVE 3 N 3 4)
(SIEVE 4 N 4 5)
(SIEVE 5 N 5 6)
(SIEVE 6 N 6 7)
(SIEVE 7 N 7 10)
(SIEVE 10 N 10 11)
(SIEVE 11 N 11 12)
(SIEVE 12 N 12 13)
(SIEVE 13 N 13 14)
(SIEVE 14 N 14 15)
(SIEVE 15 N 15 16)
(SIEVE 16 N 16 17)
(SIEVE 17 N 17 20)))
EXPR)
(DEFPROP ALLPAC
(LAMBDA NIL
(PROG NIL
(BLOB 0 0 NIL)
(BLOB 1 1 NIL)
(BLOB 2 2 NIL)
(BLOB 3 3 NIL)
(BLOB 4 4 NIL)
(BLOB 5 5 NIL)
(BLOB 6 6 NIL)
(BLOB 7 7 NIL)
(BLOB 10 10 NIL)
(BLOB 11 11 NIL)
(BLOB 12 12 NIL)
(BLOB 13 13 NIL)
(BLOB 14 14 NIL)
(BLOB 15 15 NIL)
(BLOB 16 16 NIL)
(BLOB 17 17 NIL)))
EXPR)
(DEFPROP XY
(LAMBDA NIL (CONS (TIMES 4 (MEANX 0)) (TIMES 4 (MEANY 0))))
EXPR)
(DEFPROP XY
(NIL -1000 . -1000)
VALUE)
(DEFPROP BUBBLE
(LAMBDA(ZZ)
(PROG (Z1 Z2)
(SETQ (REVERSE ZZ))
L1 (COND ((NULL (SETQ Z2 (REVERSE (CDR Z1)))) (RETURN NIL)))
L2 (COND ((OR (ZEROP (AREA (CAR Z1))) (NULL Z2)) (SETQ Z1 (CDR Z1)) (GO L1)))
(BLIT (CAR Z2) 20)
(BLIT (CAR Z1) 21)
(PIOR 21 (CAR Z2))
(PAND 20 (CAR Z1))
(SETQ Z2 (CDR Z2))
(GO L2)))
EXPR)
(DEFPROP ARDSFIT
(LAMBDA(XL XH XD ABC FLAG)
(PROG (X Y A B C V1 V2)
(SETQ X XL)
(SETQ A (CAR ABC))
(SETQ B (CADR ABC))
(SETQ C (CADDR ABC))
(SETQ Y (PLUS (TIMES (PLUS (TIMES A X) B) X) C))
(SETQ V1
(CONS (FIX (PLUS (COND (FLAG (PLUS X X)) (T (PLUS Y Y))) -700))
(FIX (DIFFERENCE 700 (COND (FLAG (PLUS Y Y)) (T (PLUS X X)))))))
L (COND ((GREATERP (SETQ X (PLUS X XD)) XH) (RETURN NIL)))
(SETQ Y (PLUS (TIMES (PLUS (TIMES A X) B) X) C))
(SETQ V2
(CONS (FIX (PLUS (COND (FLAG (PLUS X X)) (T (PLUS Y Y))) -700))
(FIX (DIFFERENCE 700 (COND (FLAG (PLUS Y Y)) (T (PLUS X X)))))))
(ARDS-VECTOR (CONS V1 V2))
(SETQ V1 V2)
(GO L)))
EXPR)
(DEFPROP BITS
(LAMBDA(NN)
(PROG (TEM FLAG)
(SETQ BASE 2)
(SETQ TEM (EXAMINE NN))
(SETQ FLAG (MINUSP TEM))
(SETQ TEM (EXPLODE (COND (FLAG (BOOLE 1 377777777777 TEM)) (T TEM))))
L (COND ((NOT (EQ (LENGTH TEM) 44)) (SETQ TEM (CONS 0 TEM)) (GO L)))
(SETQ BASE (ADD1 7))
(RETURN (COND (FLAG (CONS 1 (CDR TEM))) (T TEM)))))
EXPR)
(DEFPROP SQRED
(LAMBDA (X) (TIMES X X))
EXPR)
(DEFPROP FLATTEN
(LAMBDA (Z) (COND ((NULL Z) NIL) ((ATOM Z) (LIST Z)) (T (APPEND (FLATTEN (CAR Z)) (FLATTEN (CDR Z))))))
EXPR)
(DEFPROP FIT
(LAMBDA(L)
(PROG (EL SX SX2 SX3 SX4 SY SXY SX2Y N TX TY D DA DB DC COEFL)
(SETQ EL (ADDPTS L))
(SETQ SX 0.0)
(SETQ SX2 0.0)
(SETQ SX3 0.0)
(SETQ SX4 0.0)
(SETQ SY 0.0)
(SETQ SXY 0.0)
(SETQ SX2Y 0.0)
(SETQ N 0.0)
F5 (COND ((NULL EL) (GO F10)))
(SETQ TX (CAAR EL))
(SETQ TY (CDAR EL))
(SETQ SX (PLUS SX TX))
(SETQ SXY (PLUS SXY (TIMES TX TY)))
(SETQ SX3 (PLUS SX3 (TIMES TX TX TX)))
(SETQ TX (TIMES TX TX))
(SETQ SX2 (PLUS SX2 TX))
(SETQ SX2Y (PLUS SX2Y (TIMES TX TY)))
(SETQ SX4 (PLUS SX4 (TIMES TX TX)))
(SETQ SY (PLUS SY TY))
(SETQ N (ADD1 N))
(SETQ EL (CDR EL))
(GO F5)
F10 (SETQ D
(PLUS (TIMES SX4 SX2 N)
(TIMES SX3 SX SX2)
(TIMES SX2 SX3 SX)
(MINUS (TIMES SX2 SX2 SX2))
(MINUS (TIMES SX SX SX4))
(MINUS (TIMES N SX3 SX3))))
(SETQ DA
(PLUS (TIMES SX2Y SX2 N)
(TIMES SX3 SX SY)
(TIMES SX2 SXY SX)
(MINUS (TIMES SY SX2 SX2))
(MINUS (TIMES SX SX SX2Y))
(MINUS (TIMES N SXY SX3))))
(SETQ DB
(PLUS (TIMES SX4 SXY N)
(TIMES SX2Y SX SX2)
(TIMES SX2 SX3 SY)
(MINUS (TIMES SX2 SXY SX2))
(MINUS (TIMES SY SX SX4))
(MINUS (TIMES N SX3 SX2Y))))
(SETQ DC
(PLUS (TIMES SX4 SX2 SY)
(TIMES SX3 SXY SX2)
(TIMES SX2Y SX3 SX)
(MINUS (TIMES SX2 SX2 SX2Y))
(MINUS (TIMES SX SXY SX4))
(MINUS (TIMES SY SX3 SX3))))
(COND ((ZEROP D) (PRINT (QUOTE (ZERO DET)))))
(SETQ COEFL (LIST (QUOTIENT DA D) (QUOTIENT DB D) (QUOTIENT DC D)))
(RETURN COEFL)))
EXPR)
(DEFPROP MID
(LAMBDA (CL) (CONS (TIMES 0.5 (PLUS (CAAR CL) (CAADR CL))) (TIMES 0.5 (PLUS (CDAR CL) (CDADR CL)))))
EXPR)
(DEFPROP ADDPTS
(LAMBDA(L)
(PROG (L1 L2)
(SETQ L1 L)
(SETQ L2 NIL)
LL (COND ((NULL L1) (RETURN L2)))
(SETQ L2 (CONS (CAAR L1) (CONS (MID (CAR L1)) (CONS (CADAR L1) L2))))
(SETQ L1 (CDR L1))
(GO LL)))
EXPR)
(DEFPROP ONE16
(LAMBDA NIL
(PROG NIL
(ZIP)
(WINDOW 0 0 4 4)
(TVADD 0)
(WINDOW 0 1 4 4)
(TVADD 0)
(WINDOW 0 2 4 4)
(TVADD 0)
(WINDOW 0 3 4 4)
(TVADD 0)
(WINDOW 1 0 4 4)
(TVADD 0)
(WINDOW 1 1 4 4)
(TVADD 0)
(WINDOW 1 2 4 4)
(TVADD 0)
(WINDOW 1 3 4 4)
(TVADD 0)
(WINDOW 2 0 4 4)
(TVADD 0)
(WINDOW 2 1 4 4)
(TVADD 0)
(WINDOW 2 2 4 4)
(TVADD 0)
(WINDOW 2 3 4 4)
(TVADD 0)
(WINDOW 3 0 4 4)
(TVADD 0)
(WINDOW 3 1 4 4)
(TVADD 0)
(WINDOW 3 2 4 4)
(TVADD 0)
(WINDOW 3 3 4 4)
(TVADD 0)))
EXPR)
(DEFPROP OPEN
(LAMBDA NIL (JOINT 7 100))
EXPR)
(DEFPROP CLOSE
(LAMBDA NIL (JOINT 7 -110))
EXPR)
(DEFPROP MOMENT
(LAMBDA(N)
(PROG (A B C D)
(SETQ A (PLUS 0.0 (AREA N)))
(SETQ B (QUOTIENT (SUMX N) A))
(SETQ D (SUMSQX))
(SETQ C (QUOTIENT (SUMY N) A))
(RETURN (DIFFERENCE (PLUS D (SUMSQY)) (TIMES A B B) (TIMES A C C)))))
EXPR)
(DEFPROP MEANX
(LAMBDA (N) (QUOTIENT (SUMX N) (AREA N)))
EXPR)
(DEFPROP MEANY
(LAMBDA (N) (QUOTIENT (SUMY N) (AREA N)))
EXPR)
(DEFPROP SORT2
(LAMBDA (N M Z) (COND ((NULL (CDR Z)) N) (T (PROG2 (SIEVE N M (CAR Z) (CADR Z)) (SORT2 (ADD1 N) M (CDR Z))))))
EXPR)
(DEFPROP SORT
(LAMBDA(N M)
(PROG (Z)
(SETQ Z (CROSSZ M))
(RETURN
(COND ((NULL (CDR Z)) N) (T (PROG2 (SIEVE N M (CAR Z) (CADR Z)) (SORT2 (ADD1 N) M (CDR Z))))))))
EXPR)
(DEFPROP CROSSZ
(LAMBDA (N) (APPEND (CONS 0 (CROSSINGS (DIFFS (HIST N)) 1)) (QUOTE (20))))
EXPR)
(DEFPROP HIST
(LAMBDA(N)
(PROG (M Z)
(SETQ M 17)
(SETQ Z NIL)
L (SETQ Z (CONS (EXAMINE (PLUS (TIMES 20 N) HSTV M)) Z))
(COND ((EQ -1 (SETQ M (SUB1 M))) (RETURN Z)) (T (GO L)))))
EXPR)
(DEFPROP DIFFS
(LAMBDA (Z) (COND ((NULL (CDR Z)) NIL) (T (CONS (DIFFERENCE (CAR Z) (CADR Z)) (DIFFS (CDR Z))))))
EXPR)
(DEFPROP CROSSINGS
(LAMBDA(Z N)
(COND ((NULL (CDR Z)) NIL)
(T
(COND ((AND (MINUSP (CADR Z)) (NOT (MINUSP (CAR Z)))) (CONS N (CROSSINGS (CDR Z) (ADD1 N))))
(T (CROSSINGS (CDR Z) (ADD1 N)))))))
EXPR)
(DEFPROP INITFLIP
(LAMBDA NIL
(PROG NIL
(SETQ PC (CAR (GETSYM SUBR PAC)))
(SETQ HSTV (CAR (GETSYM SUBR HISTOV)))
(GETSYM SUBR ADDC SUBC IMULC IDIVC)
(GETSYM SUBR DADDC DSUBC MULC DIVC)
(GETSYM SUBR CASH CABS ZIPALL CZIP ZIPNEG CROUND CASHAL)
(GETSYM SUBR SICMUL SICDIV SICADD SICSUB)
(GETSYM SUBR LSD LOCMAX PFLIP PSET)
(GETSYM SUBR ZOOM PACLST CWGET CWPUT)
(GETSYM SUBR PZIP PNOT PXOR PIOR PAND PEQU)
(GETSYM SUBR BORDER INTIOR PDOT)
(GETSYM SUBR BIMPA ABIMP BONLY AONLY)
(GETSYM SUBR NAND PNOR DRUMO DRUMI DRUMZ NOW)
(GETSYM SUBR BLOT YMAX YMIN XMINW INARDS)
(GETSYM SUBR CARCON HIND FORE HEAD STOP RUN)
(GETSYM SUBR TVWEE DISKO DISKI TV)
(GETSYM SUBR DDT ARM DAC GREY GRAY)
(GETSYM SUBR PAYROT PAYSH PAXROT PAXSH)
(GETSYM SUBR SQR ARCTAN SINE COSINE)
(GETSYM SUBR JOINT TSINIT LENS SWS WINDOW UNWIND)
(GETSYM SUBR LSD ZIP TVADD TVSUB)
(GETSYM SUBR ARDDOT ARDVEC ARDEOF ARDNVC ARDFF)
(GETSYM SUBR PAXROT PAXSH)
(GETSYM SUBR TVMOVE TVPACK FOCUS PAN TILT)
(GETSYM SUBR LOGIC HISTO SIEVE)
(GETSYM SUBR PAXROT PAXSH PAYROT PAYSH PRISS PROSS)
(GETSYM SUBR AREA PPP TTT)
(GETSYM SUBR FFF STOPWAR PACO SEED BLIT XYFLIP)))
EXPR)
(DEFPROP SAFE
(LAMBDA NIL (DSKOUT (FLIP . LSP) (GRINL ALLFNS)))
EXPR)